home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
netmail
/
rnr214.zip
/
PRINTMSG.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-03-01
|
11KB
|
468 lines
program printmsg;
{
Russell_Schulz@locutus.ofB.ORG (960202)
Copyright 1996 Russell Schulz
this code is not in the Public Domain
permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason. have fun.
}
uses dos,genericf,rdheader;
const
{
languagelist='ps,pcl';
}
languagelist='ps';
defaultlanguage='ps';
defaultoutputfn='lpt1';
var
firstfnparam: integer;
outputfn: string;
language: string;
maxlines: longint;
procedure usage;
begin
writeln('printmsg -- print message');
writeln;
writeln('usage:');
writeln(' printmsg [optional-parameters] file [file ...]');
writeln;
writeln('options:');
writeln(' -o file send output to filename, default ',defaultoutputfn);
writeln(' -l language select printer language from "',languagelist,
'", default: ',defaultlanguage);
writeln(' -m lines specify maxinum number of lines to print');
writeln;
writeln('Russell_Schulz@locutus.ofB.ORG (960202)');
halt(1);
end;
procedure msgusage(s: string);
begin
writeln(s);
usage;
end;
procedure initialize;
var
currparami: integer;
currparams: string;
nextparams: string;
begin
outputfn := defaultoutputfn;
language := defaultlanguage;
maxlines := 0;
if paramcount<1 then
usage;
firstfnparam := 1;
currparami := 1;
while currparami<=paramcount do
begin
currparams := paramstr(currparami);
if currparami<paramcount then
nextparams := paramstr(currparami+1)
else
nextparams := '';
if currparams='-?' then
usage
else if currparams='-o' then
begin
if nextparams='' then
msgusage('-o requires a filename');
outputfn := nextparams;
inc(currparami);
end
else if currparams='-l' then
begin
if nextparams='' then
msgusage('-l requires a language');
language := nextparams;
inc(currparami);
if pos(','+language+',',','+languagelist+',')=0 then
msgusage('language '+language+' not recognized');
end
else if currparams='-m' then
begin
if nextparams='' then
msgusage('-m requires an integer');
maxlines := atol(nextparams);
inc(currparami);
end
else if currparams='--' then
begin
firstfnparam := currparami+1;
currparami := paramcount;
end
else if copy(currparams,1,1)<>'-' then
begin
firstfnparam := currparami;
currparami := paramcount;
end
else
msgusage('unknown parameter: '+currparams);
inc(currparami);
end;
if paramcount<firstfnparam then
msgusage('at least one filename must be specified');;
end;
function newline(oneline: string): string;
var
result: string;
chari: integer;
charc: char;
begin
result := '';
result := result+'(';
for chari := 1 to length(oneline) do
begin
charc := oneline[chari];
if (charc='(') or (charc=')') or (charc='\') then
result := result+'\';
result := result+charc;
end;
result := result+')';
newline := result;
end;
procedure outputline(var outputf: text; oneline: string);
const
minlength=20;
maxlength=90;
var
mangledline: string;
partoftheline: string;
breakpoint: integer;
possiblebreakpoint: integer;
indent: string;
begin
mangledline := oneline;
{want to do this at least once, even if oneline is empty}
repeat
partoftheline := mangledline;
if length(partoftheline)<=maxlength then
mangledline := ''
else
begin
indent := '';
{break on the last possible word. this leaves a trailing space (which is ok)}
breakpoint := 0;
for possiblebreakpoint := minlength to maxlength do
if partoftheline[possiblebreakpoint]=' ' then
begin
breakpoint := possiblebreakpoint;
indent := ' ';
end;
{handle long Path: headers}
if breakpoint=0 then
begin
for possiblebreakpoint := minlength to maxlength do
if partoftheline[possiblebreakpoint]='!' then
begin
breakpoint := possiblebreakpoint;
indent := ' ';
end;
end;
{handle long Newsgroups: headers}
if breakpoint=0 then
begin
for possiblebreakpoint := minlength to maxlength do
if partoftheline[possiblebreakpoint]=',' then
begin
breakpoint := possiblebreakpoint;
indent := ' ';
end;
end;
{look for anything!}
if breakpoint=0 then
begin
for possiblebreakpoint := minlength to maxlength do
if not isalpha(partoftheline[possiblebreakpoint]) then
begin
breakpoint := possiblebreakpoint;
indent := ' ';
end;
end;
{nowhere nice to break. oh well. just break it so we can see it}
if breakpoint=0 then
breakpoint := maxlength;
partoftheline := copy(partoftheline,1,breakpoint);
mangledline := indent+copy(mangledline,breakpoint+1,255);
end;
writeln(outputf,newline(partoftheline),' n');
until mangledline='';
end;
procedure printheader(left,middle,right: string);
begin
end;
procedure printfooter(left,middle,right: string);
begin
end;
procedure printonemsg(var outputf: text; inputfn: string);
const
switchtofontlength=20;
type
fontt=(plain, bold, italics);
var
inputf: text;
inheaders: boolean;
numlines: longint;
oneline: string;
headername: string;
headerfrom: string;
headerdate: string;
headersubject: string;
currentfont: fontt;
newfont: fontt;
switchtofont: array[fontt] of string[switchtofontlength];
begin
switchtofont[plain] := 'plain';
switchtofont[bold] := 'bold';
switchtofont[italics] := 'italics';
{need to do this now to avoid problems with SHARE}
headerfrom := getheaderline(inputfn,'from:');
headerdate := getheaderline(inputfn,'date:');
headersubject := getheaderline(inputfn,'subject:');
assign(inputf,inputfn);
{$I-}
reset(inputf);
{$I+}
if ioresult<>0 then
msgusage('could not read '+inputfn);
writeln(outputf,'% begin ',inputfn);
writeln(outputf);
writeln(outputf,'/pageno 0 def');
writeln(outputf);
writeln(outputf,'/headerfrom ',newline(headerfrom),' def');
writeln(outputf,'/headerdate ',newline(headerdate),' def');
writeln(outputf,'/headersubject ',newline(headersubject),' def');
writeln(outputf);
writeln(outputf,'startpage');
writeln(outputf);
currentfont := plain;
inheaders := true;
numlines := 0;
while ((maxlines=0) or (numlines<=maxlines)) and not eof(inputf) do
begin
inc(numlines);
read(inputf,oneline);
if eoln(inputf) then
readln(inputf);
if oneline='' then
inheaders := false;
newfont := plain;
if inheaders then
begin
{}{}{}{} {handle hiding}
headername := lower(getfirstw(oneline));
if headername='date:' then
newfont := bold;
if headername='from:' then
newfont := bold;
if headername='to:' then
newfont := bold;
if headername='subject:' then
newfont := bold;
if currentfont<>newfont then
writeln(outputf,switchtofont[newfont]);
outputline(outputf,oneline);
end
else
begin
{}{}{}{} {handle paragraph breaks, quoting}
if copy(oneline,1,1)='>' then
newfont := italics;
if currentfont<>newfont then
writeln(outputf,switchtofont[newfont]);
outputline(outputf,oneline);
end;
currentfont := newfont;
end;
writeln(outputf,'showpage');
writeln(outputf);
writeln(outputf,'% end ',inputfn);
writeln(outputf);
close(inputf);
end;
procedure printprelude(var outputf: text);
begin
writeln(outputf,'%! PS');
writeln(outputf);
writeln(outputf,'/bigbold');
writeln(outputf,'{');
writeln(outputf,' /Courier-Bold findfont 16 scalefont setfont');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/bold');
writeln(outputf,'{');
writeln(outputf,' /Courier-Bold findfont 10 scalefont setfont');
writeln(outputf,' /vertdiff 12 def');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/italics');
writeln(outputf,'{');
writeln(outputf,' /Courier-Oblique findfont 8 scalefont setfont');
writeln(outputf,' /vertdiff 10 def');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/plain');
writeln(outputf,'{');
writeln(outputf,' /Courier findfont 10 scalefont setfont');
writeln(outputf,' /vertdiff 12 def');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/header');
writeln(outputf,'{');
writeln(outputf,' 20 750 moveto headerfrom show');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/footer');
writeln(outputf,'{');
writeln(outputf,' 20 50 moveto headerdate show');
writeln(outputf,' 500 50 moveto (Page ) show pageno pagenostr cvs show');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/startpage');
writeln(outputf,'{');
writeln(outputf,' /vert 720 def');
writeln(outputf,' /pageno pageno 1 add def');
writeln(outputf,' bigbold');
writeln(outputf,' header');
writeln(outputf,' footer');
writeln(outputf,' plain');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/newpage');
writeln(outputf,'{');
writeln(outputf,' showpage');
writeln(outputf,' startpage');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/n');
writeln(outputf,'{');
writeln(outputf,'% check here if vert is <100, and if so start a new page');
writeln(outputf,' vert 100 lt {newpage} if');
writeln(outputf,' 20 vert moveto');
writeln(outputf,' show');
writeln(outputf,' /vert vert vertdiff sub def');
writeln(outputf,'} def');
writeln(outputf);
writeln(outputf,'/pagenostr 20 string def');
writeln(outputf);
end;
procedure printpostlude(var outputf: text);
begin
writeln(outputf,'% done');
end;
procedure process;
var
outputf: text;
eachparam: integer;
inputfn: string;
fileinfo: searchrec;
begin
assign(outputf,outputfn);
{$I-}
rewrite(outputf);
{$I+}
if ioresult<>0 then
msgusage('could not write to '+outputfn);
printprelude(outputf);
for eachparam := firstfnparam to paramcount do
begin
inputfn := unslash(paramstr(eachparam));
{}{}{}{} {handle wildcards}
printonemsg(outputf,inputfn);
end;
printpostlude(outputf);
close(outputf);
end;
procedure shutdown;
begin
end;
begin {main}
initialize;
process;
shutdown;
end.